Magnum One/Magnum One (Mid-American Digital) (Disc Manufacturing).iso/d18/err_func.arc/ERR_FUNC.PAS

Pascal/Delphi Source File | 1990-09-16 | 22.0 KB | 626 lines

{$O+,F+}
Unit Err_Func;

INTERFACE

Uses CRT,DOS;


VAR
    Exit_Msg : String;
    Old_Exit : Pointer;
    InitSP : Word;

IMPLEMENTATION
Type
    Q_ptr = ^Q_Data;
    Q_Data = record
                      Next : Q_Ptr;
                      Line_to_display : byte;
                      Err_Address : pointer;
                      Err_Seg : String[4];
                      Err_Ofs : String[4];
                      Err_Unit : String[30];
                      Err_Line : Longint;
                end;

VAR
   Stack_q : Q_ptr;
   Current_Line : Q_Ptr;
   Prev_Line : Q_Ptr;

  {$L STAKDUMP}        {Kim Kokkokonnen's STAKDUMP routine from the Tpro Bonus Disk}
  procedure Trace;
    {-Dump stack of return addresses}
  external;

FUNCTION Exist(Filename:string):boolean;
{returns true if file exists}
VAR File_Rec: SearchRec;
begin
    FindFirst(Filename,AnyFile,File_Rec);
    Exist := (DOSError = 0);
end;  {Func Exist}

FUNCTION Strip_Blank(S : String) : String;
VAR Lng : byte ABSOLUTE S;
begin
     {Strip Blanks before Source string}
     While S[1] = ' ' do
           Delete(S,1,1);
     {Strip Blanks After Source string}
     While S[lng] = ' ' do
           Delete(S,lng,1);
     Strip_Blank := S;
end;

FUNCTION Str2Int(S : String) :Integer;
VAR I,E : integer;
begin
     Val(S,I,E);
     Str2Int := I;
end;

FUNCTION Int2Str(I : Integer) :String;
VAR S : String;
begin
     Str(I,S);
     Int2Str := S;
end;

FUNCTION Hex(w : Word) : STRING;
const
  hexChars : array [0..$F] of Char =
    '0123456789ABCDEF';
begin
  hEX :=hexChars[Hi(w) shr 4]+hexChars[Hi(w) and $F]+
    hexChars[Lo(w) shr 4]+hexChars[Lo(w) and $F];
END;

Function Hex_to_int(h : String) : word;
const
  hexChars : String[16] = '0123456789ABCDEF';
var f : word;
begin
     f := 0;
     while length(h) > 0 do
     begin
          if pos(Copy(h,1,1),HexChars) = 0 then
              f := 0
          Else
              f := (f*16)+pos(H[1],Hexchars)-1;
          delete(h,1,1);
     end;
     Hex_to_int := f;
end;

FUNCTION SHOW_PTR(p : POINTER) : STRING;
BEGIN
       IF P = NIL THEN
        sHOW_PTR := 'NIL'
       else
        SHOW_PTR := HEX(SEG(P^))+':'+HEX(OFS(P^));
END;

Procedure Ext_Error(Var ex_code ,Class , Action, Locus : byte);
var
  Regs : Registers;
begin
  Regs.AH := $59;
  Regs.BX := 00;
  MsDos(Regs);
  Ex_code := Regs.AX;
  Class := Regs.BH;
  Action := Regs.BL;
  Locus := Regs.CH;
end;  { Ext_Error }

Function  Ptr_Between(Test,Min,Max : pointer) : Boolean;
var
     Ptr_addr ,
     top_addr,
     bott_addr,
     temp_addr : longint;
begin
     Ptr_addr := seg(Test^);
     Ptr_addr := (ptr_addr*16);
     Ptr_addr := ptr_addr+ofs(Test^);
     top_addr := seg(Max^);
     top_addr := (top_addr*16);
     top_addr := top_addr+ofs(Max^);
     bott_addr := seg(min^);
     bott_addr:=(bott_addr*16);
     bott_addr:=bott_addr+ofs(min^);
     if Bott_addr > top_addr then
     begin
          temp_addr := bott_addr;
          bott_addr := top_addr;
          Top_addr := temp_addr;
     end;
     Ptr_Between := (Ptr_addr >= bott_addr) AND (Ptr_addr < top_addr);
end;

Procedure Insert_to_Queue(_Line : Byte; _Error_seg, _Error_ofs : word);
VAR Temp_Line : Q_Ptr;
    Temp_addr : longint;
begin
     {Insert Line, and err_address to Q, blank Data}
     New(Temp_Line);
     Fillchar(Temp_Line^,Sizeof(Temp_Line^),0);
     Temp_Line^.Line_to_Display := _Line;
     Temp_Line^.Err_Address := ptr(_Error_seg,_Error_Ofs);
     Temp_Line^.err_seg := Hex(_Error_seg);
     Temp_Line^.err_ofs := Hex(_Error_ofs);
     Current_Line := Stack_Q^.next;
     Prev_Line := Stack_Q;
     While (Current_Line <> Stack_Q)
       AND (seg(Current_Line^.Err_Address^) < _ERROR_seg)
       AND (ofs(Current_Line^.Err_Address^) < _ERROR_ofs) do
     begin
          Prev_Line := Current_Line;
          Current_Line := Current_Line^.next;
     end;
     Prev_Line^.next := temp_Line;
     Temp_Line^.next := Current_Line;
end;


Procedure Print_Q_Data;
VAR
  Map_File : TEXT;
  Map_Name : PathStr;
  Map_Dir  : dirStr;
  MAP_FlNm : NameStr;
  MAP_Ext  : ExtStr;
  Map_Line : String;
  Text_Buff : pointer;
  Text_Sze : longint;
  Valid_Map : Boolean;
  Line_Col : Byte;
  old_t,
  T_Line,
  Count_t : Byte;
  Suspect_Unit : NameStr;
  Suspect_Line : Integer;
  Suspect_Seg ,
  Suspect_Ofs : Longint;
  found_Here : boolean;

begin
     {Going through Q fill in Details as you come to them}
     {Open MAP file at Paramstr[0]'s path}

     Textcolor(lightgreen);
     Old_T := wherey;
     fsplit(Fexpand(Paramstr(0)),Map_dir,Map_FlNm,Map_Ext);
     Map_Name := Map_Dir+Map_FLNm+'.MAP';
     IF NOT(EXIST(Map_Name)) then
     begin
           Writeln('No MAP file found at '+Map_Name);
           Writeln;
           Valid_Map := False;
     end
     ELSE
     begin
           Valid_Map := True;
           {Open Map File}
           ASSIGN(Map_File,Map_Name);
           Text_Sze := Maxavail - 2048;
           if Text_Sze > 65520 then
              Text_Sze := 65520;
           If Text_Sze > 1024 then
           begin
                getmem(Text_Buff,Text_Sze);
                SetTextBuf(Map_File,Text_Buff^,Text_Sze);
           end;
           Reset(Map_File);
           MAP_Line := '';
           {Read lines until eof or _Start__Stop}
           TextColor(lightblue);
           While (copy(MAP_Line,1,12) <> ' Start  Stop') and not(eof(Map_File)) do
           begin
                Readln(Map_File,Map_Line);
           end;
           IF EOF(Map_File) then
           begin
                Writeln;
                Writeln('Can''t Find Segments in Map File '+Map_Name);
                Valid_Map := False;
           end
     end;
     found_here := false;
     If Valid_Map then
     begin
           {Reset the list}
           Current_Line := Stack_Q^.next;

           {First go thru Segment info fillin the list}
           Readln(Map_File,Map_Line);
           Readln(Map_File,Map_Line);
           {Read Lines until EOF or not CODE}
           Write('Reading '+Map_Name+' for SEGMENT Info :');
           While Not(EOF(MAP_File))
             and (Map_Line <> '')
             and (Current_Line <> Stack_Q) do
           begin
               found_here := false;
               if random(2) = 1 then Write('.');
               {Check if 2-4 = Int-hex Error Addr}
               If copy(Map_Line,2,4) > Current_Line^.err_seg then
               begin
                    {This is it}
                    Current_Line^.Err_Unit := 'Unknown (No Segment Data)';
                    Current_line := Current_Line^.next;
               end;
               If copy(Map_Line,2,4) = Current_Line^.err_seg then
               begin
                    {This is it}
                    Current_Line^.Err_Unit := strip_Blank(copy(Map_Line,23,18));
                    Current_line := Current_Line^.next;
                    found_here := true;
               end;
               if not Found_here then
                    Readln(Map_File,Map_Line);
          end;
          While Current_Line <> Stack_q do
          begin
               Current_Line^.Err_Unit := 'Unknown (No Segment Data)';
               Current_Line := Current_Line^.next;
          end;

          {Skip publics info}
          Writeln;
          {Loop through until LINE}
          While (not(EOF(Map_File)) AND
                (copy(Map_Line,1,4) <> 'Line')) do
          begin
               Readln(Map_File,Map_Line);
          end;
          If eof(Map_File) then
          begin
               Writeln;
               Writeln('Program was not compiled with Line number info');
          end;
          Current_Line := Stack_Q^.next;
          {Go through Line number info}
          Write('Reading '+Map_Name+' for LINE Info :');
          {Search for err_seg:_err_Ofs in each of the four possitions}

          While (not(EOF(Map_File))
            AND (Current_Line <> Stack_Q)) do
          begin
               if random(20) = 1 then Write('.');
               For Line_Col := 0 to 3 do
               begin
                     found_here := True;
                     while Found_here do
                     begin
                          found_here := False;
                          if copy(map_line,12,1) <> ':' then
                               Suspect_Seg := -1
                          Else
                          begin
                               Suspect_Seg := Hex_to_int(copy(Map_Line,(Line_Col*16)+8,4));
                               Suspect_Ofs := Hex_to_int(copy(Map_Line,(Line_Col*16)+13,4));
                          end;
                          if Suspect_seg > seg(Current_Line^.Err_Address^) then
                          begin
                               Current_Line^.Err_Line := 0;
                               Current_Line := Current_Line^.next;
                          end;
                          if Suspect_seg = seg(Current_Line^.Err_Address^) then
                          begin
                               IF (copy(Map_Line,(Line_Col*16)+13,4) >= Current_Line^.Err_Ofs) THEN
                               begin
                                    Current_Line^.Err_Line := Str2int(strip_Blank(copy(Map_line,line_col*16+1,6)));
                                    Current_Line := Current_Line^.next;
                                    found_here := true;
                               end;
                          end;
                     end;
               end;
               if Not found_here then
                  Readln(Map_File,Map_Line);
          end;
          While Current_Line <> Stack_Q do
          begin
               Current_Line^.Err_Line := 0;
               Current_line := Current_Line^.next;
          end;
     end;{Valid_Map}
     {Close Map}
     Close(Map_File);
     If Text_Sze > 1024 then
     begin
          freemem(Text_Buff,Text_Sze);
     end;
     t_Line := wherey;
     for count_t := Old_T to t_Line do
     begin
          GotoXY(1,Count_t);
          Clreol;
     end;
     Gotoxy(1,old_t);
     {Then Print out Q data}
     Current_Line := Stack_Q^.next;
     While Current_Line <> Stack_Q do
     begin
          GotoXY(15,Current_Line^.Line_to_Display);
          with Current_Line^ do
          begin
               if Err_Line = 0 then
                   Write('Location :'+strip_Blank(err_Unit)+'  No Line Data')
               Else
                   Write('Location :'+strip_Blank(err_Unit)+'  On or just before Line:'+int2str(err_Line));
          end;
          Current_Line := current_Line^.next;
     end;
end;

{$F+}

Procedure Exit_Message;

type    Spot   = record
            case boolean of
                0 : (Character : Char;
                     Attribute : Byte);
                1 : (Pair      : word);
         end;
    Screen = array[1..25,0..79] of Spot;

VAR
  Dos_Err,E,c,a,l : byte;
  blank : integer;
  err_s : string;
  Old_T,
  count_t : Byte;
  T_Line : Byte;
  TPas_Err : String;
  Max_Line : word;
  found_max : Boolean;
  Text0 : screen absolute $B800:$0000;
  T_1,
  T_2 : word;
  Output_File : TEXT;

begin
     textmode(3);
     Exitproc := old_Exit;
     TextColor(Yellow);
     if (ErrorAddr <> nil) and (Mem[PrefixSeg:5] <> $C3) then
     begin
          {Error not previously handled, and not in user-interface Turbo}
          {Reset output to CRT, to give some pretty colours}

          AssignCrt(Output);
          Rewrite(Output);

          {STRONGARM SOME HEAP SPACE, If other error functions need heap
          memory make sure they are activated first, ie: Initialised later
          in the program, CONFUSED? Sorry just take my word for it :-}

          RELEASE(HeapOrg);

          {Firstly find out the Turbo Pascal error name}

          Case ExitCode of
                1: TPas_Err := 'Invalid DOS function code';
                2: TPas_Err := 'File not found';
                3: TPas_Err := 'Path not found';
                4: TPas_Err := 'Too many open files';
                5: TPas_Err := 'File access denied';
                6: TPas_Err := 'Invalid file handle';
                8: TPas_Err := 'Not enough memory';
               12: TPas_Err := 'Invalid file access code';
               15: TPas_Err := 'Invalid drive number';
               16: TPas_Err := 'Cannot remove current directory';
               17: TPas_Err := 'Cannot rename across drives';
              100: TPas_Err := 'Disk read error';
              101: TPas_Err := 'Disk write error';
              102: TPas_Err := 'File not assigned';
              103: TPas_Err := 'File not open';
              104: TPas_Err := 'File not open for input';
              105: TPas_Err := 'File not open for output';
              106: TPas_Err := 'Invalid numeric format';
              150: TPas_Err := 'Disk is write-protected';
              151: TPas_Err := 'Unknown unit';
              152: TPas_Err := 'Drive not ready';
              153: TPas_Err := 'Unknown command';
              154: TPas_Err := 'CRC error in data';
              155: TPas_Err := 'Bad Drive request structure length';
              156: TPas_Err := 'Disk seek error';
              157: TPas_Err := 'Unknown media type';
              158: TPas_Err := 'Sector not found';
              159: TPas_Err := 'Printer out of Paper';
              160: TPas_Err := 'Device write fault';
              161: TPas_Err := 'Device read fault';
              162: TPas_Err := 'Hardware failure';
              200: TPas_Err := 'Division by zero';
              201: TPas_Err := 'Range check error';
              202: TPas_Err := 'Stack overflow error';
              203: TPas_Err := 'Heap overflow error';
              204: TPas_Err := 'Invalid pointer operation';
              205: TPas_Err := 'Floating point overflow';
              206: TPas_Err := 'Floating point underflow';
              207: TPas_Err := 'Invalid floating point operation';
              208: TPas_Err := 'Overlay manager not installed';
              209: TPas_Err := 'Overlay file read error';
              ELSE TPas_Err := 'Unknown Error code';
          end;
          {Put out the standard Turbo Run-Time Error message}

          Writeln('Run-Time Error ['+int2str(exitcode)+'] '+TPas_Err+'  at  '+Show_ptr(ErrorAddr));
          Textcolor(White);

          {Put out any special application warning}
          Writeln('Special routine exit message: ',Exit_Msg);
          Writeln;
          {Find the extended error code}
          Ext_Error(e ,C , A, L);
          Dos_Err := DosError;
          If Dos_Err <> 0 then
          begin
               Textcolor(LightCyan);
               Writeln('DOS Extended error report shows:');
               Case E of
                 1 : Err_S := 'Invalid function number';
                 2 : Err_S := 'File not found';
                 3 : Err_S := 'Path not found';
                 4 : Err_S := 'Too many open files (no handles left)';
                 5 : Err_S := 'Access denied (file was opened Read Only)';
                 6 : Err_S := 'Invalid handle';
                 7 : Err_S := 'Memory control blocks destroyed';
                 8 : Err_S := 'Insufficient memory';
                 9 : Err_S := 'Invalid memory block address';
                10 : Err_S := 'Invalid environment';
                11 : Err_S := 'Invalid format';
                12 : Err_S := 'Invalid access code';
                13 : Err_S := 'Invalid data';
                15 : Err_S := 'Invalid drive was specified';
                16 : Err_S := 'Attempt to remove current directory';
                17 : Err_S := 'Not same device';
                18 : Err_S := 'No more files';
                19 : Err_S := 'Attempt to write on write-protected diskette';
                20 : Err_S := 'Unknown unit';
                21 : Err_S := 'Drive not ready';
                22 : Err_S := 'Unknown command';
                23 : Err_S := 'Data error (CRC)';
                24 : Err_S := 'Bad request structure length';
                25 : Err_S := 'Seek error';
                26 : Err_S := 'Unknown media type';
                27 : Err_S := 'Sector not found';
                28 : Err_S := 'Printer out of paper';
                29 : Err_S := 'Write fault';
                30 : Err_S := 'Read fault';
                31 : Err_S := 'General failure';
                32 : Err_S := 'Sharing violation';
                33 : Err_S := 'Lock violation';
                34 : Err_S := 'Invalid disk change';
                35 : Err_S := 'FCB unavailable';
                36 : Err_S := 'Sharing buffer overflow';
                50 : Err_S := 'Network request not supported';
                51 : Err_S := 'Remote computer not listening';
                52 : Err_S := 'Duplicate name on network';
                53 : Err_S := 'Network name not found';
                54 : Err_S := 'Network busy';
                55 : Err_S := 'Network device no longer exists';
                56 : Err_S := 'Net BIOS command limit exceeded';
                57 : Err_S := 'Network adapter hardware error';
                58 : Err_S := 'Incorrect response from network';
                59 : Err_S := 'Unexpected network error';
                60 : Err_S := 'Incompatible remote adapter';
                61 : Err_S := 'Print queue full';
                62 : Err_S := 'Not enough space for print file';
                63 : Err_S := 'Print file was deleted';
                65 : Err_S := 'Access denied';
                66 : Err_S := 'Network device type incorrect';
                67 : Err_S := 'Network name not found';
                68 : Err_S := 'Network name limit exceeded';
                69 : Err_S := 'Net BIOS session limit exceeded';
                70 : Err_S := 'Temporarily paused';
                71 : Err_S := 'Network request not accepted';
                72 : Err_S := 'Print or disk redirection is paused';
                80 : Err_S := 'File exists';
                82 : Err_S := 'Cannot make directory entry';
                83 : Err_S := 'Fail on INT 24';
                84 : Err_S := 'Too many redirections';
                85 : Err_S := 'Duplicate redirection';
                86 : Err_S := 'Invalid password';
                87 : Err_S := 'Invalid parameter';
                88 : Err_S := 'Network device fault';
               end;
               Writeln('Extended Error Code:',err_s);
               Case c of
                 1 : Err_S := 'Out of resource';
                 2 : Err_S := 'Temporary situation';
                 3 : Err_S := 'Permission problem';
                 4 : Err_S := 'Internal error in system software';
                 5 : Err_S := 'Hardware failure';
                 6 : Err_S := 'Serious failure of system software';
                 7 : Err_S := 'Application program error';
                 8 : Err_S := 'File/item not found';
                 9 : Err_S := 'File/item of invalid format or type';
                10 : Err_S := 'File/item interlocked';
                11 : Err_S := 'Media failure: wrong disk, CRC error...';
                12 : Err_S := 'Collision with existing item';
                13 : Err_S := 'Classification doesn''t exist or is inappropriate';
               end;
               Writeln('Error Class        :',err_s);
               Case a of
                 1 : Err_S := 'Retry';
                 2 : Err_S := 'Retry after pause';
                 3 : Err_S := 'Ask user to re-enter input';
                 4 : Err_S := 'Abort program with cleanup';
                 5 : Err_S := 'Abort immediately, skip cleanup';
                 6 : Err_S := 'Ignore';
                 7 : Err_S := 'Retry after user intervention';
               end;
               Writeln('Recommended Action :',err_s);
               Case l of
                 1 : Err_S := 'Unknown or inappropriate';
                 2 : Err_S := 'Related to disk storage';
                 3 : Err_S := 'Related to the network';
                 4 : Err_S := 'Serial device';
                 5 : Err_S := 'Memory';
               end;
               Writeln('Error Locus        :',err_s);
               Writeln('');
          end;
          Writeln('Trace into Procedure Stack Shows:');
          {Trace from error address to top of stack}
          Trace;  {With many thanks to Kim Kokonnen for this routine}
          Writeln;
          Old_T := Wherey;
          T_Line := wherey-2;
          new(Stack_Q);
          Stack_Q^.next := Stack_Q;
          While (T_Line > 1) AND (Text0[T_Line,0].Character<>'T') do
          begin
               {From Cursor Position Grab each Trace pointer and find it's Map}
               T_1 :=hex_to_int(Text0[T_Line,0].Character+
                                Text0[T_Line,1].Character+
                                Text0[T_Line,2].Character+
                                Text0[T_Line,3].Character);
               T_2:=hex_to_int(Text0[T_Line,5].Character+
                                Text0[T_Line,6].Character+
                                Text0[T_Line,7].Character+
                                Text0[T_Line,8].Character);
               Insert_to_Queue(T_Line, T_1 , T_2);
               {Go up list putting pointer data into insertion sorted Queue}
               dec(T_Line);
          end;
          Print_Q_Data;    {Now add info to those stack positions}
          GotoXY(1,Old_t);
          {Show All Error Data}
          {Stop remaining handlers from reporting error}
          ErrorAddr := nil;
          Textcolor(lightgray);
          writeln('Press any key to continue');
          while not keypressed do;
     end
     ELSE
     begin
        {You used HALT(X) to get out}
        if exitcode <> 0 then
        begin
           Writeln('Application Exit Code :'+Int2str(Exitcode));
           Writeln('Routine exit message:',Exit_Msg);
        end;
     end;
end;
{$F-}


begin
        {Save initial stack pointer}
        InitSP := SPtr+4;
        {Set up ExitProc}
        Exit_Msg := '';
        Old_Exit := exitProc;
        Exitproc := @Exit_Message;
end.